home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / b / b.lha / B / src / bint / b1obj.c < prev    next >
Encoding:
C/C++ Source or Header  |  1988-11-24  |  7.0 KB  |  319 lines
  1. /* Copyright (c) Stichting Mathematisch Centrum, Amsterdam, 1985. */
  2.  
  3. /*
  4.   $Header: b1obj.c,v 1.4 85/08/22 16:52:13 timo Exp $
  5. */
  6.  
  7. /* Generic routines for all values */
  8.  
  9. #include "b.h"
  10. #include "b1obj.h"
  11. #ifndef INTEGRATION
  12. #include "b1btr.h"
  13. #include "b1val.h"
  14. #endif
  15. #include "b1tlt.h"
  16. #include "b3err.h"
  17. #include "b3typ.h"
  18.  
  19. #ifndef INTEGRATION
  20.  
  21. Visible bool comp_ok = Yes;         /* Temporary, to catch type errors */
  22.  
  23. relation comp_tlt(), comp_text();    /* From b1lta.c */
  24.  
  25. Hidden Procedure incompatible(v, w) value v, w; {
  26.     value message, m1, m2, m3, m4, m5, m6;
  27.     message= concat(m1= convert(m2= (value) valtype(v), No, No),
  28.          m3= concat(m4= mk_text(" and "),
  29.          m5= convert(m6= (value) valtype(w), No, No)));
  30.     error2(MESS(1400, "incompatible types "), message);
  31.     release(message);
  32.     release(m1); release(m2); release(m3);
  33.     release(m4); release(m5); release(m6);
  34. }
  35.  
  36. Visible relation compare(v, w) value v, w; {
  37.     literal vt, wt;
  38.     int i;
  39.     relation rel;
  40.     
  41.     comp_ok = Yes;
  42.  
  43.     if (v EQ w) return(0);
  44.     if (IsSmallInt(v) && IsSmallInt(w))
  45.         return SmallIntVal(v) - SmallIntVal(w);
  46.     vt = Type(v);
  47.     wt = Type(w);
  48.     switch (vt) {
  49.     case Num:
  50.         if (wt != Num) {
  51.  incomp:
  52.             /*Temporary until static checks are implemented*/
  53.              incompatible(v, w);
  54.             comp_ok= No;
  55.             return -1;
  56.          }
  57.         return(numcomp(v, w));
  58.     case Com:
  59.         if (wt != Com || Nfields(v) != Nfields(w)) goto incomp;
  60.         for (i = 0; i < Nfields(v); i++) {
  61.             rel = compare(*Field(v, i), *Field(w, i));
  62.             if (rel NE 0) return(rel);
  63.         }
  64.         return(0);
  65.     case Tex:
  66.         if (wt != Tex) goto incomp;
  67.         return(comp_text(v, w));
  68.     case Lis:
  69.         if (wt != Lis && wt != ELT) goto incomp;
  70.         return(comp_tlt(v, w));
  71.     case Tab:
  72.         if (wt != Tab && wt != ELT) goto incomp;
  73.         return(comp_tlt(v, w));
  74.     case ELT:
  75.         if (wt != Tab && wt != Lis && wt != ELT) goto incomp;
  76.         return(Root(w) EQ Bnil ? 0 : -1);
  77.     default: 
  78.         syserr(MESS(1401, "comparison of unknown types"));
  79.         /*NOTREACHED*/
  80.     }
  81. }
  82.  
  83. /* Used for set'random. Needs to be rewritten so that for small changes in v */
  84. /* you get large changes in hash(v) */
  85.  
  86. Visible double hash(v) value v; {
  87.     if (Is_number(v)) return numhash(v);
  88.     else if (Is_compound(v)) {
  89.         int len= Nfields(v), k; double d= .404*len;
  90.         k_Overfields {
  91.             d= .874*d+.310*hash(*Field(v, k));
  92.         }
  93.         return d;
  94.     } else {
  95.         int len= length(v), k; double d= .404*len;
  96.         if (len == 0) return .909;
  97.         else if (Is_text(v)) {
  98.             value ch;
  99.             k_Over_len {
  100.                 ch= thof(k+1, v);
  101.                 d= .987*d+.277*charval(ch);
  102.                 release(ch);
  103.             }
  104.             return d;
  105.         } else if (Is_list(v)) {
  106.             value el;
  107.             k_Over_len {
  108.                 d= .874*d+.310*hash(el= thof(k+1, v));
  109.                 release(el);
  110.             }
  111.             return d;
  112.         } else if (Is_table(v)) {
  113.             k_Over_len {
  114.                 d= .874*d+.310*hash(*key(v, k))
  115.                      +.123*hash(*assoc(v, k));
  116.             }
  117.             return d;
  118.         } else {
  119.             syserr(MESS(1402, "hash called with unknown type"));
  120.             return (double) Dummy;
  121.         }
  122.     }
  123. }
  124.  
  125. Hidden Procedure concato(v, t) value* v; value t; {
  126.     value v1= *v;
  127.     *v= concat(*v, t);
  128.     release(v1);
  129. }
  130.  
  131. Visible value convert(v, coll, outer) value v; bool coll, outer; {
  132.     value t, quote, c, cv, sep, th, open, close; int k, len; char ch;
  133.     switch (Type(v)) {
  134.     case Num:
  135.         return mk_text(convnum(v));
  136.     case Tex:
  137.         if (outer) return copy(v);
  138.         quote= mk_text("\"");
  139.         len= length(v);
  140.         t= copy(quote);
  141.         for (k=1; k<=len; k++) {
  142.             c= thof(k, v);
  143.             ch= charval(c);
  144.             concato(&t, c);
  145.             if (ch == '"' || ch == '`') concato(&t, c);
  146.             release(c);
  147.         }
  148.         concato(&t, quote);
  149.         release(quote);
  150.         break;
  151.     case Com:
  152.         len= Nfields(v);
  153.         outer&= coll;
  154.         sep= mk_text(outer ? " " : ", ");
  155.         t= mk_text(coll ? "" : "(");
  156.         k_Over_len {
  157.             concato(&t, cv= convert(*Field(v, k), No, outer));
  158.             release(cv);
  159.             if (!Last(k)) concato(&t, sep);
  160.         }
  161.         release(sep);
  162.         if (!coll) {
  163.             concato(&t, cv= mk_text(")"));
  164.             release(cv);
  165.         }
  166.         break;
  167.     case Lis:
  168.     case ELT:
  169.         len= length(v);
  170.         t= mk_text("{");
  171.         sep= mk_text("; ");
  172.         for (k=1; k<=len; k++) {
  173.             concato(&t, cv= convert(th= thof(k, v), No, No));
  174.             release(cv); release(th);
  175.             if (k != len) concato(&t, sep);
  176.         }
  177.         release(sep);
  178.         concato(&t, cv= mk_text("}"));
  179.         release(cv);
  180.         break;
  181.     case Tab:
  182.         len= length(v);
  183.         open= mk_text("[");
  184.         close= mk_text("]: ");
  185.         sep= mk_text("; ");
  186.         t= mk_text("{");
  187.         k_Over_len {
  188.             concato(&t, open);
  189.             concato(&t, cv= convert(*key(v, k), Yes, No));
  190.             release(cv);
  191.             concato(&t, close);
  192.             concato(&t, cv= convert(*assoc(v, k), No, No));
  193.             release(cv);
  194.             if (!Last(k)) concato(&t, sep);
  195.         }
  196.         concato(&t, cv= mk_text("}")); release(cv);
  197.         release(open); release(close); release(sep);
  198.         break;
  199.     default:
  200.         if (bugs || testing) {
  201.             t= mk_text("?");
  202.             concato(&t, cv= mkchar(Type(v))); release(cv);
  203.             concato(&t, cv= mkchar('$')); release(cv);
  204.             break;
  205.         }
  206.         syserr(MESS(1403, "unknown type in convert"));
  207.     }
  208.     return t;
  209. }
  210.  
  211. Hidden value adj(v, w, side) value v, w; char side; {
  212.     value t, c, sp, r, i;
  213.     int len, wid, diff, left, right;
  214.     c= convert(v, Yes, Yes);
  215.     len= length(c);
  216.     wid= intval(w);
  217.     if (wid<=len) return c;
  218.     else {
  219.         diff= wid-len;
  220.         if (side == 'L') { left= 0; right= diff; }
  221.         else if (side == 'R') { left= diff; right= 0; }
  222.         else {left= diff/2; right= (diff+1)/2; }
  223.         sp= mk_text(" ");
  224.         if (left == 0) t= c;
  225.         else {
  226.             t= repeat(sp, i= mk_integer(left)); release(i);
  227.             concato(&t, c);
  228.             release(c);
  229.         }
  230.         if (right != 0) {
  231.             r= repeat(sp, i= mk_integer(right)); release(i);
  232.             concato(&t, r);
  233.             release(r);
  234.         }
  235.         release(sp);
  236.         return t;
  237.     }
  238. }
  239.  
  240. Visible value adjleft(v, w) value v, w; {
  241.     return adj(v, w, 'L');
  242. }
  243.  
  244. Visible value adjright(v, w) value v, w; {
  245.     return adj(v, w, 'R');
  246. }
  247.  
  248. Visible value centre(v, w) value v, w; {
  249.     return adj(v, w, 'C');
  250. }
  251.  
  252. #else INTEGRATION
  253.  
  254. #define Sgn(d) (d)
  255.  
  256. Visible relation compare(v, w) value v, w; {
  257.     literal vt= Type(v), wt= Type(w);
  258.     register intlet vlen, wlen, len, k;
  259.     value message;
  260.     vlen= IsSmallInt(v) ? 0 : Length(v);
  261.     wlen= IsSmallInt(w) ? 0 : Length(w);
  262.     if (v == w) return 0;
  263.     if (!(vt == wt && !(vt == Com && vlen != wlen) ||
  264.                 vt == ELT && (wt == Lis || wt == Tab) ||
  265.                 wt == ELT && (vt == Lis || vt == Tab))) {
  266.         message= concat(convert((value) valtype(v), No, No),
  267.              concat(mk_text(" and "),
  268.              convert((value) valtype(w), No, No)));
  269.         error2(MESS(1404, "incompatible types "), message);
  270.                /*doesn't return: so can't release message*/
  271.     }
  272.     if (vt != Num && (vlen == 0 || wlen == 0))
  273.         return Sgn(vlen-wlen);
  274.     switch (vt) {
  275.     case Num: return numcomp(v, w);
  276.     case Tex: return strcmp(Str(v), Str(w));
  277.  
  278.     case Com:
  279.     case Lis:
  280.     case Tab:
  281.     case ELT:
  282.         {value *vp= Ats(v), *wp= Ats(w);
  283.          relation c;
  284.             len= vlen < wlen ? vlen : wlen;
  285.             Overall if ((c= compare(*vp++, *wp++)) != 0) return c;
  286.             return Sgn(vlen-wlen);
  287.         }
  288.     default:
  289.         syserr(MESS(1405, "comparison of unknown types"));
  290.         /* NOTREACHED */
  291.     }
  292. }
  293.  
  294. Visible double hash(v) value v; {
  295.     literal t= Type(v); intlet len= Length(v), k; double d= t+.404*len;
  296.     switch (t) {
  297.     case Num: return numhash(v);
  298.     case Tex:
  299.         {string vp= Str(v);
  300.             Overall d= .987*d+.277*(*vp++);
  301.             return d;
  302.         }
  303.     case Com:
  304.     case Lis:
  305.     case Tab:
  306.     case ELT:
  307.         {value *vp= Ats(v);
  308.             if (len == 0) return .909;
  309.             Overall d= .874*d+.310*hash(*vp++);
  310.             return d;
  311.         }
  312.     default:
  313.         syserr(MESS(1406, "hash called with unknown type"));
  314.         /* NOTREACHED */
  315.     }
  316. }
  317.  
  318. #endif INTEGRATION
  319.